home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / scmactst.scm < prev    next >
Encoding:
Text File  |  1994-05-25  |  3.4 KB  |  140 lines
  1. ;;;"scmactst.scm" test syntactic closures macros
  2. ;;; From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson
  3.  
  4. (require 'test)
  5. (require 'syntactic-closures)
  6.  
  7. (macro:expand
  8.  '(define-syntax push
  9.     (syntax-rules ()
  10.           ((push item list)
  11.            (set! list (cons item list))))))
  12.  
  13. (test '(set! foo (cons bar foo)) 'push (macro:expand '(push bar foo)))
  14.  
  15. (macro:expand
  16.  '(define-syntax push1
  17.     (transformer
  18.      (lambda (exp env)
  19.        (let ((item
  20.           (make-syntactic-closure env '() (cadr exp)))
  21.          (list
  22.           (make-syntactic-closure env '() (caddr exp))))
  23.      `(set! ,list (cons ,item ,list)))))))
  24.  
  25. (test '(set! foo (cons bar foo)) 'push1 (macro:expand '(push1 bar foo)))
  26.  
  27. (macro:expand
  28.  '(define-syntax loop
  29.     (transformer
  30.      (lambda (exp env)
  31.        (let ((body (cdr exp)))
  32.      `(call-with-current-continuation
  33.        (lambda (exit)
  34.          (let f ()
  35.            ,@(map (lambda  (exp)
  36.             (make-syntactic-closure env '(exit)
  37.                         exp))
  38.               body)
  39.            (f)))))))))
  40.  
  41. (macro:expand
  42.  '(define-syntax let1
  43.     (transformer
  44.      (lambda (exp env)
  45.        (let ((id (cadr exp))
  46.          (init (caddr exp))
  47.          (exp (cadddr exp)))
  48.      `((lambda (,id)
  49.          ,(make-syntactic-closure env (list id) exp))
  50.        ,(make-syntactic-closure env '() init)))))))
  51.  
  52. (test 93 'let1 (macro:eval '(let1 a 90 (+ a 3))))
  53.  
  54. (macro:expand
  55.  '(define-syntax loop-until
  56.     (syntax-rules
  57.      ()
  58.      ((loop-until id init test return step)
  59.       (letrec ((loop
  60.         (lambda (id)
  61.           (if test return (loop step)))))
  62.     (loop init))))))
  63.  
  64. (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
  65.                (loop 3)))
  66.       'loop
  67.       (macro:expand '(loop-until foo 3 #t 12 33)))
  68.  
  69. (macro:expand
  70.  '(define-syntax loop-until1
  71.     (transformer
  72.      (lambda (exp env)
  73.        (let ((id (cadr exp))
  74.          (init (caddr exp))
  75.          (test (cadddr exp))
  76.          (return (cadddr (cdr exp)))
  77.          (step (cadddr (cddr exp)))
  78.          (close
  79.           (lambda (exp free)
  80.         (make-syntactic-closure env free exp))))
  81.      `(letrec ((loop
  82.             ,(capture-syntactic-environment
  83.               (lambda (env)
  84.             `(lambda (,id)
  85.                (,(make-syntactic-closure env '() `if)
  86.                 ,(close test (list id))
  87.                 ,(close return (list id))
  88.                 (,(make-syntactic-closure env '()
  89.                               `loop)
  90.                  ,(close step (list id)))))))))
  91.         (loop ,(close init '()))))))))
  92.  
  93. (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
  94.                   (loop 3)))
  95.       'loop1
  96.       (macro:expand '(loop-until1 foo 3 #t 12 33)))
  97.  
  98. (test '#t 'identifier (identifier? 'a))
  99. ;;; this needs to setup ENV.
  100. ;;;(test '#t 'identifier
  101. ;;;      (identifier? (macro:expand (make-syntactic-closure env '() 'a))))
  102. (test #f 'identifier (identifier? "a"))
  103. (test #f 'identifier (identifier? #\a))
  104. (test #f 'identifier (identifier? 97))
  105. (test #f 'identifier (identifier? #f))
  106. (test #f 'identifier (identifier? '(a)))
  107. (test #f 'identifier (identifier? '#(a)))
  108.  
  109. (test '(#t #f)
  110.       'syntax
  111.       (macro:eval
  112.        '(let-syntax
  113.         ((foo
  114.           (transformer
  115.            (lambda (form env)
  116.          (capture-syntactic-environment
  117.           (lambda (transformer-env)
  118.             (identifier=? transformer-env 'x env 'x)))))))
  119.       (list (foo)
  120.         (let ((x 3))
  121.           (foo))))))
  122.  
  123.  
  124. (test '(#f #t)
  125.       'syntax
  126.       (macro:eval
  127.        '(let-syntax ((bar foo))
  128.       (let-syntax
  129.           ((foo
  130.         (transformer
  131.          (lambda (form env)
  132.            (capture-syntactic-environment
  133.             (lambda (transformer-env)
  134.               (identifier=? transformer-env 'foo
  135.                     env (cadr form))))))))
  136.         (list (foo foo)
  137.           (foo bar))))))
  138.  
  139. (report-errs)
  140.